home *** CD-ROM | disk | FTP | other *** search
/ AGA Toolkit '97 / The AGA Toolkit '97.iso / miscellaneous / science / maths / calc / source / func.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-09-07  |  49.7 KB  |  2,150 lines
  1. /*
  2.  * Copyright (c) 1994 David I. Bell
  3.  * Permission is granted to use, distribute, or modify this source,
  4.  * provided that this copyright notice remains intact.
  5.  *
  6.  * Modified for the Amiga by Steve Leblanc, Oct 1995
  7.  *
  8.  * Built-in functions implemented here
  9.  */
  10.  
  11. #include <sys/types.h>
  12. #include <time.h>
  13.  
  14. #include "calc.h"
  15. #include "opcodes.h"
  16. #include "token.h"
  17. #include "func.h"
  18. #include "string.h"
  19. #include "symbol.h"
  20.  
  21.  
  22. extern int errno;
  23.  
  24.  
  25. /*
  26.  * Totally numeric functions.
  27.  */
  28. static NUMBER *f_cfsim();    /* simplify number using continued fractions */
  29. static NUMBER *f_ilog();    /* return log of one number to another */
  30. static NUMBER *f_faccnt();    /* count of divisions */
  31. static NUMBER *f_min();        /* minimum of several arguments */
  32. static NUMBER *f_max();        /* maximum of several arguments */
  33. static NUMBER *f_hmean();    /* harmonic mean */
  34. static NUMBER *f_trunc();    /* truncate number to specified decimal places */
  35. static NUMBER *f_btrunc();    /* truncate number to specified binary places */
  36. static NUMBER *f_gcd();        /* greatest common divisor */
  37. static NUMBER *f_lcm();        /* least common multiple */
  38. static NUMBER *f_xor();        /* xor of several arguments */
  39. static NUMBER *f_ceil();    /* ceiling of a fraction */
  40. static NUMBER *f_floor();    /* floor of a fraction */
  41. static NUMBER *f_meq();        /* numbers are same modular value */
  42. static NUMBER *f_isrel();    /* two numbers are relatively prime */
  43. static NUMBER *f_ismult();    /* whether one number divides another */
  44. static NUMBER *f_mne();        /* whether a and b are not equal modulo c */
  45. static NUMBER *f_isset();    /* tests if a bit of a num (base 2) is set */
  46. static NUMBER *f_highbit();    /* high bit number in base 2 representation */
  47. static NUMBER *f_lowbit();    /* low bit number in base 2 representation */
  48. static NUMBER *f_near();    /* whether two numbers are near each other */
  49. static NUMBER *f_legtoleg();    /* positive form of leg to leg */
  50. static NUMBER *f_ilog10();    /* integer log of number base 10 */
  51. static NUMBER *f_ilog2();    /* integer log of number base 2 */
  52. static NUMBER *f_digits();    /* number of digits of number */
  53. static NUMBER *f_digit();    /* digit at specified decimal place of number */
  54. static NUMBER *f_places();    /* number of decimal places of number */
  55. static NUMBER *f_primetest();    /* primality test */
  56. static NUMBER *f_issquare();    /* whether number is a square */
  57. static NUMBER *f_runtime();    /* user runtime in seconds */
  58. static NUMBER *f_base();    /* set default output base */
  59.  
  60.  
  61. /*
  62.  * General functions.
  63.  */
  64. static VALUE f_hash();        /* produce hash from values */
  65. static VALUE f_bround();    /* round number to specified binary places */
  66. static VALUE f_round();        /* round number to specified decimal places */
  67. static VALUE f_det();        /* determinant of matrix */
  68. static VALUE f_mattrans();    /* return transpose of matrix */
  69. static VALUE f_matdim();    /* dimension of matrix */
  70. static VALUE f_matmax();    /* maximum index of matrix dimension */
  71. static VALUE f_matmin();    /* minimum index of matrix dimension */
  72. static VALUE f_matfill();    /* fill matrix with values */
  73. static VALUE f_listpush();    /* push element onto front of list */
  74. static VALUE f_listpop();    /* pop element from front of list */
  75. static VALUE f_listappend();    /* append element to end of list */
  76. static VALUE f_listremove();    /* remove element from end of list */
  77. static VALUE f_listinsert();    /* insert element into list */
  78. static VALUE f_listdelete();    /* delete element from list */
  79. static VALUE f_strlen();    /* length of string */
  80. static VALUE f_char();        /* character value of integer */
  81. static VALUE f_substr();    /* extract substring */
  82. static VALUE f_strcat();    /* concatenate strings */
  83. static VALUE f_ord();        /* get ordinal value for character */
  84. static VALUE f_avg();        /* average of several arguments */
  85. static VALUE f_ssq();        /* sum of squares */
  86. static VALUE f_poly();        /* result of evaluating polynomial */
  87. static VALUE f_sqrt();        /* square root of a number */
  88. static VALUE f_root();        /* number taken to root of another */
  89. static VALUE f_exp();        /* complex exponential */
  90. static VALUE f_ln();        /* complex natural logarithm */
  91. static VALUE f_power();        /* one value to another power */
  92. static VALUE f_cos();        /* complex cosine */
  93. static VALUE f_sin();        /* complex sine */
  94. static VALUE f_polar();        /* polar representation of complex number */
  95. static VALUE f_arg();        /* argument of complex number */
  96. static VALUE f_list();        /* create a list */
  97. static VALUE f_size();        /* number of elements in object */
  98. static VALUE f_search();    /* search matrix or list for match */
  99. static VALUE f_rsearch();    /* search matrix or list backwards for match */
  100. static VALUE f_cp();        /* cross product of vectors */
  101. static VALUE f_dp();        /* dot product of vectors */
  102. static VALUE f_prompt();    /* prompt for input line */
  103. static VALUE f_eval();        /* evaluate string into value */
  104. static VALUE f_str();        /* convert value to string */
  105. static VALUE f_fopen();        /* open file for reading or writing */
  106. static VALUE f_fprintf();    /* print data to file */
  107. static VALUE f_strprintf();    /* return printed data as a string */
  108. static VALUE f_fgetline();    /* read next line from file */
  109. static VALUE f_fgetc();        /* read next char from file */
  110. static VALUE f_fflush();    /* flush output to file */
  111. static VALUE f_printf();    /* print data to stdout */
  112. static VALUE f_fclose();    /* close file */
  113. static VALUE f_ferror();    /* whether error occurred */
  114. static VALUE f_feof();        /* whether end of file reached */
  115. static VALUE f_files();        /* return file handle or number of files */
  116. static VALUE f_assoc();        /* return a new association value */
  117.  
  118.  
  119. #define IN 100        /* maximum number of arguments */
  120. #define    FE 0x01        /* flag to indicate default epsilon argument */
  121. #define    FA 0x02        /* preserve addresses of variables */
  122.  
  123.  
  124. /*
  125.  * List of primitive built-in functions
  126.  */
  127. static struct builtin {
  128.     char *b_name;        /* name of built-in function */
  129.     short b_minargs;    /* minimum number of arguments */
  130.     short b_maxargs;    /* maximum number of arguments */
  131.     short b_flags;        /* special handling flags */
  132.     short b_opcode;        /* opcode which makes the call quick */
  133.     NUMBER *(*b_numfunc)();    /* routine to calculate numeric function */
  134.     VALUE (*b_valfunc)();    /* routine to calculate general values */
  135.     char *b_desc;        /* description of function */
  136. } builtins[] = {
  137.     "abs", 1, 2, 0, OP_ABS, 0, 0, "absolute value within accuracy b",
  138.     "acos", 1, 2, FE, OP_NOP, qacos, 0, "arccosine of a within accuracy b",
  139.     "acosh", 1, 2, FE, OP_NOP, qacosh, 0, "hyperbolic arccosine of a within accuracy b",
  140.     "append", 2, 2, FA, OP_NOP, 0, f_listappend, "append value to end of list",
  141.     "appr", 1, 2, FE, OP_NOP, qbappr, 0, "approximate a with simpler fraction to within b",
  142.     "arg", 1, 2, 0, OP_NOP, 0, f_arg, "argument (the angle) of complex number",
  143.     "asin", 1, 2, FE, OP_NOP, qasin, 0, "arcsine of a within accuracy b",
  144.     "asinh", 1, 2, FE, OP_NOP, qasinh, 0, "hyperbolic arcsine of a within accuracy b",
  145.     "assoc", 0, 0, 0, OP_NOP, 0, f_assoc, "create new association array",
  146.     "atan", 1, 2, FE, OP_NOP, qatan, 0, "arctangent of a within accuracy b",
  147.     "atan2", 2, 3, FE, OP_NOP, qatan2, 0, "angle to point (b,a) within accuracy c",
  148.     "atanh", 1, 2, FE, OP_NOP, qatanh, 0, "hyperbolic arctangent of a within accuracy b",
  149.     "avg", 1, IN, 0, OP_NOP, 0, f_avg, "arithmetic mean of values",
  150.     "base", 0, 1, 0, OP_NOP, f_base, 0, "set default output base",
  151.     "bround", 1, 2, 0, OP_NOP, 0, f_bround, "round value a to b number of binary places",
  152.     "btrunc", 1, 2, 0, OP_NOP, f_btrunc, 0, "truncate a to b number of binary places",
  153.     "ceil", 1, 1, 0, OP_NOP, f_ceil, 0, "smallest integer greater than or equal to number",
  154.     "cfappr", 1, 2, FE, OP_NOP, qcfappr, 0, "approximate a within accuracy b using\n\t\t    continued fractions",
  155.     "cfsim", 1, 1, 0, OP_NOP, f_cfsim, 0, "simplify number using continued fractions",
  156.     "char", 1, 1, 0, OP_NOP, 0, f_char, "character corresponding to integer value",
  157.     "cmp", 2, 2, 0, OP_CMP, 0, 0, "compare values returning -1, 0, or 1",
  158.     "comb", 2, 2, 0, OP_NOP, qcomb, 0, "combinatorial number a!/b!(a-b)!",
  159.     "config", 1, 2, 0, OP_SETCONFIG, 0, 0, "set or read configuration value",
  160.     "conj", 1, 1, 0, OP_CONJUGATE, 0, 0, "complex conjugate of value",
  161.     "cos", 1, 2, 0, OP_NOP, 0, f_cos, "cosine of value a within accuracy b",
  162.     "cosh", 1, 2, FE, OP_NOP, qcosh, 0, "hyperbolic cosine of a within accuracy b",
  163.     "cp", 2, 2, 0, OP_NOP, 0, f_cp, "Cross product of two vectors",
  164.     "delete", 2, 2, FA, OP_NOP, 0, f_listdelete, "delete element from list a at position b",
  165.     "den", 1, 1, 0, OP_DENOMINATOR, qden, 0, "denominator of fraction",
  166.     "det", 1, 1, 0, OP_NOP, 0, f_det, "determinant of matrix",
  167.     "digit", 2, 2, 0, OP_NOP, f_digit, 0, "digit at specified decimal place of number",
  168.     "digits", 1, 1, 0, OP_NOP, f_digits, 0, "number of digits in number",
  169.     "dp", 2, 2, 0, OP_NOP, 0, f_dp, "Dot product of two vectors",
  170.     "epsilon", 0, 1, 0, OP_SETEPSILON, 0, 0, "set or read allowed error for real calculations",
  171.     "eval", 1, 1, 0, OP_NOP, 0, f_eval, "Evaluate expression from string to value",
  172.     "exp", 1, 2, 0, OP_NOP, 0, f_exp, "exponential of value a within accuracy b",
  173.     "fcnt", 2, 2, 0, OP_NOP, f_faccnt, 0, "count of times one number divides another",
  174.     "fib", 1, 1, 0, OP_NOP, qfib, 0, "Fibonacci number F(n)",
  175.     "frem", 2, 2, 0, OP_NOP, qfacrem, 0, "number with all occurrences of factor removed",
  176.     "fact", 1, 1, 0, OP_NOP, qfact, 0, "factorial",
  177.     "fclose", 1, 1, 0, OP_NOP, 0, f_fclose, "close file",
  178.     "feof", 1, 1, 0, OP_NOP, 0, f_feof, "whether EOF reached for file",
  179.     "ferror", 1, 1, 0, OP_NOP, 0, f_ferror, "whether error occurred for file",
  180.     "fflush", 1, 1, 0, OP_NOP, 0, f_fflush, "flush output to file",
  181.     "fgetc", 1, 1, 0, OP_NOP, 0, f_fgetc, "read next char from file",
  182.     "fgetline", 1, 1, 0, OP_NOP, 0, f_fgetline, "read next line from file",
  183.     "files", 0, 1, 0, OP_NOP, 0, f_files, "return opened file or max number of opened files",
  184.     "floor", 1, 1, 0, OP_NOP, f_floor, 0, "greatest integer less than or equal to number",
  185.     "fopen", 2, 2, 0, OP_NOP, 0, f_fopen, "open file name a in mode b",
  186.     "fprintf", 2, IN, 0, OP_NOP, 0, f_fprintf, "print formatted output to opened file",
  187.     "frac", 1, 1, 0, OP_FRAC, qfrac, 0, "fractional part of value",
  188.     "gcd", 1, IN, 0, OP_NOP, f_gcd, 0, "greatest common divisor",
  189.     "gcdrem", 2, 2, 0, OP_NOP, qgcdrem, 0, "a divided repeatedly by gcd with b",
  190.     "hash", 1, IN, 0, OP_NOP, 0, f_hash, "return non-negative hash value for one or\n\t\t    more values",
  191.     "highbit", 1, 1, 0, OP_NOP, f_highbit, 0, "high bit number in base 2 representation",
  192.     "hmean", 1, IN, 0, OP_NOP, f_hmean, 0, "harmonic mean of values",
  193.     "hypot", 2, 3, FE, OP_NOP, qhypot, 0, "hypotenuse of right triangle within accuracy c",
  194.     "ilog", 2, 2, 0, OP_NOP, f_ilog, 0, "integral log of one number with another",
  195.     "ilog10", 1, 1, 0, OP_NOP, f_ilog10, 0, "integral log of a number base 10",
  196.     "ilog2", 1, 1, 0, OP_NOP, f_ilog2, 0, "integral log of a number base 2",
  197.     "im", 1, 1, 0, OP_IM, 0, 0, "imaginary part of complex number",
  198.     "insert", 3, 3, FA, OP_NOP, 0, f_listinsert, "insert value c into list a at position b",
  199.      "int", 1, 1, 0, OP_INT, qint, 0, "integer part of value",
  200.     "inverse", 1, 1, 0, OP_INVERT, 0, 0, "multiplicative inverse of value",
  201.     "iroot", 2, 2, 0, OP_NOP, qiroot, 0, "integer b'th root of a",
  202.     "isassoc", 1, 1, 0, OP_ISASSOC, 0, 0, "whether a value is an association",
  203.     "iseven", 1, 1, 0, OP_ISEVEN, 0, 0, "whether a value is an even integer",
  204.     "isfile", 1, 1, 0, OP_ISFILE, 0, 0, "whether a value is a file",
  205.     "isint", 1, 1, 0, OP_ISINT, 0, 0, "whether a value is an integer",
  206.     "islist", 1, 1, 0, OP_ISLIST, 0, 0, "whether a value is a list",
  207.     "ismat", 1, 1, 0, OP_ISMAT, 0, 0, "whether a value is a matrix",
  208.     "ismult", 2, 2, 0, OP_NOP, f_ismult, 0, "whether a is a multiple of b",
  209.     "isnull", 1, 1, 0, OP_ISNULL, 0, 0, "whether a value is the null value",
  210.     "isnum", 1, 1, 0, OP_ISNUM, 0, 0, "whether a value is a number",
  211.     "isobj", 1, 1, 0, OP_ISOBJ, 0, 0, "whether a value is an object",
  212.     "isodd", 1, 1, 0, OP_ISODD, 0, 0, "whether a value is an odd integer",
  213.     "isqrt", 1, 1, 0, OP_NOP, qisqrt, 0, "integer part of square root",
  214.     "isreal", 1, 1, 0, OP_ISREAL, 0, 0, "whether a value is a real number",
  215.     "isrel", 2, 2, 0, OP_NOP, f_isrel, 0, "whether two numbers are relatively prime",
  216.     "isset", 2, 2, 0, OP_NOP, f_isset, 0, "whether bit b of abs(a) (in base 2) is set",
  217.     "isstr", 1, 1, 0, OP_ISSTR, 0, 0, "whether a value is a string",
  218.     "issimple", 1, 1, 0, OP_ISSIMPLE, 0, 0, "whether value is a simple type",
  219.     "issq", 1, 1, 0, OP_NOP, f_issquare, 0, "whether or not number is a square",
  220.      "istype", 2, 2, 0, OP_ISTYPE, 0, 0, "whether the type of a is same as the type of b",
  221.     "jacobi", 2, 2, 0, OP_NOP, qjacobi, 0, "-1 => a is not quadratic residue mod b\n\t\t  1 => b is composite, or a is quad residue of b",
  222.     "lcm", 1, IN, 0, OP_NOP, f_lcm, 0, "least common multiple",
  223.     "lcmfact", 1, 1, 0, OP_NOP, qlcmfact, 0, "lcm of all integers up till number",
  224.     "lfactor", 2, 2, 0, OP_NOP, qlowfactor, 0, "lowest prime factor of a in first b primes",
  225.     "list", 0, IN, 0, OP_NOP, 0, f_list, "create list of specified values",
  226.     "ln", 1, 2, 0, OP_NOP, 0, f_ln, "natural logarithm of value a within accuracy b",
  227.     "lowbit", 1, 1, 0, OP_NOP, f_lowbit, 0, "low bit number in base 2 representation",
  228.     "ltol", 1, 2, FE, OP_NOP, f_legtoleg, 0, "leg-to-leg of unit right triangle (sqrt(1 - a^2))",
  229.     "matdim", 1, 1, 0, OP_NOP, 0, f_matdim, "number of dimensions of matrix",
  230.     "matfill", 2, 3, FA, OP_NOP, 0, f_matfill, "fill matrix with value b (value c on diagonal)",
  231.     "matmax", 2, 2, 0, OP_NOP, 0, f_matmax, "maximum index of matrix a dim b",
  232.     "matmin", 2, 2, 0, OP_NOP, 0, f_matmin, "minimum index of matrix a dim b",
  233.     "mattrans", 1, 1, 0, OP_NOP, 0, f_mattrans, "transpose of matrix",
  234.     "max", 1, IN, 0, OP_NOP, f_max, 0, "maximum value",
  235.     "meq", 3, 3, 0, OP_NOP, f_meq, 0, "whether a and b are equal modulo c",
  236.     "min", 1, IN, 0, OP_NOP, f_min, 0, "minimum value",
  237.     "minv", 2, 2, 0, OP_NOP, qminv, 0, "inverse of a modulo b",
  238.     "mmin", 2, 2, 0, OP_NOP, qminmod, 0, "a mod b value with smallest abs value",
  239.     "mne", 3, 3, 0, OP_NOP, f_mne, 0, "whether a and b are not equal modulo c",
  240.     "near", 2, 3, 0, OP_NOP, f_near, 0, "sign of (abs(a-b) - c)",
  241.     "norm", 1, 1, 0, OP_NORM, 0, 0, "norm of a value (square of absolute value)",
  242.     "null", 0, 0, 0, OP_UNDEF, 0, 0, "null value",
  243.     "num", 1, 1, 0, OP_NUMERATOR, qnum, 0, "numerator of fraction",
  244.     "ord", 1, 1, 0, OP_NOP, 0, f_ord, "integer corresponding to character value",
  245.     "param", 1, 1, 0, OP_ARGVALUE, 0, 0, "value of parameter n (or parameter count if n\n\t\t    is zero)",
  246.     "perm", 2, 2, 0, OP_NOP, qperm, 0, "permutation number a!/(a-b)!",
  247.     "pfact", 1, 1, 0, OP_NOP, qpfact, 0, "product of primes up till number",
  248.     "pi", 0, 1, FE, OP_NOP, qpi, 0, "value of pi accurate to within epsilon",
  249.     "places", 1, 1, 0, OP_NOP, f_places, 0, "places after decimal point (-1 if infinite)",
  250.     "pmod", 3, 3, 0, OP_NOP, qpowermod,0, "mod of a power (a ^ b (mod c))",
  251.     "polar", 2, 3, 0, OP_NOP, 0, f_polar, "complex value of polar coordinate (a * exp(b*1i))",
  252.     "poly", 2, IN, 0, OP_NOP, 0, f_poly, "(a1,a2,...,an,x) = a1*x^n+a2*x^(n-1)+...+an",
  253.     "pop", 1, 1, FA, OP_NOP, 0, f_listpop, "pop value from front of list",
  254.     "power", 2, 3, 0, OP_NOP, 0, f_power, "value a raised to the power b within accuracy c",
  255.     "ptest", 2, 2, 0, OP_NOP, f_primetest, 0, "probabilistic primality test",
  256.     "printf", 1, IN, 0, OP_NOP, 0, f_printf, "print formatted output to stdout",
  257.     "prompt", 1, 1, 0, OP_NOP, 0, f_prompt, "prompt for input line using value a",
  258.     "push", 2, 2, FA, OP_NOP, 0, f_listpush, "push value onto front of list",
  259.     "quomod", 4, 4, 0, OP_QUOMOD, 0, 0, "set c and d to quotient and remainder of a\n\t\t    divided by b",
  260.     "rcin", 2, 2, 0, OP_NOP, qredcin, 0, "convert normal number a to REDC number mod b",
  261.     "rcmul", 3, 3, 0, OP_NOP, qredcmul, 0, "multiply REDC numbers a and b mod c",
  262.     "rcout", 2, 2, 0, OP_NOP, qredcout, 0, "convert REDC number a mod b to normal number",
  263.     "rcpow", 3, 3, 0, OP_NOP, qredcpower, 0, "raise REDC number a to power b mod c",
  264.     "rcsq", 2, 2, 0, OP_NOP, qredcsquare, 0, "square REDC number a mod b",
  265.     "re", 1, 1, 0, OP_RE, 0, 0, "real part of complex number",
  266.     "remove", 1, 1, FA, OP_NOP, 0, f_listremove, "remove value from end of list",
  267.     "root", 2, 3, 0, OP_NOP, 0, f_root, "value a taken to the b'th root within accuracy c",
  268.     "round", 1, 2, 0, OP_NOP, 0, f_round, "round value a to b number of decimal places",
  269.     "rsearch", 2, 3, 0, OP_NOP, 0, f_rsearch, "reverse search matrix or list for value b\n\t\t    starting at index c",
  270.     "runtime", 0, 0, 0, OP_NOP, f_runtime, 0, "user mode cpu time in seconds",
  271.     "scale", 2, 2, 0, OP_SCALE, 0, 0, "scale value up or down by a power of two",
  272.     "search", 2, 3, 0, OP_NOP, 0, f_search, "search matrix or list for value b starting\n\t\t    at index c",
  273.     "sgn", 1, 1, 0, OP_SGN, qsign, 0, "sign of value (-1, 0, 1)",
  274.     "sin", 1, 2, 0, OP_NOP, 0, f_sin, "sine of value a within accuracy b",
  275.     "sinh", 1, 2, FE, OP_NOP, qsinh, 0, "hyperbolic sine of a within accuracy b",
  276.     "size", 1, 1, 0, OP_NOP, 0, f_size, "total number of elements in value",
  277.     "sqrt", 1, 2, 0, OP_NOP, 0, f_sqrt, "square root of value a within accuracy b",
  278.     "ssq", 1, IN, 0, OP_NOP, 0, f_ssq, "sum of squares of values",
  279.     "str", 1, 1, 0, OP_NOP, 0, f_str, "simple value converted to string",
  280.     "strcat", 1,IN, 0, OP_NOP, 0, f_strcat, "concatenate strings together",
  281.     "strlen", 1, 1, 0, OP_NOP, 0, f_strlen, "length of string",
  282.     "strprintf", 1, IN, 0, OP_NOP, 0, f_strprintf, "return formatted output as a string",
  283.     "substr", 3, 3, 0, OP_NOP, 0, f_substr, "substring of a from position b for c chars",
  284.     "swap", 2, 2, 0, OP_SWAP, 0, 0, "swap values of variables a and b (can be dangerous)",
  285.     "tan", 1, 2, FE, OP_NOP, qtan, 0, "tangent of a within accuracy b",
  286.     "tanh", 1, 2, FE, OP_NOP, qtanh, 0, "hyperbolic tangent of a within accuracy b",
  287.     "trunc", 1, 2, 0, OP_NOP, f_trunc, 0, "truncate a to b number of decimal places",
  288.     "xor", 1, IN, 0, OP_NOP, f_xor, 0, "logical xor",
  289.     NULL, 0, 0, 0, OP_NOP, 0, 0, NULL /* end of table */
  290. };
  291.  
  292.  
  293. /*
  294.  * Call a built-in function.
  295.  * Arguments to the function are on the stack, but are not removed here.
  296.  * Functions are either purely numeric, or else can take any value type.
  297.  */
  298. VALUE
  299. builtinfunc(index, argcount, stck)
  300.     int argcount;
  301.     long index;
  302.     VALUE *stck;        /* arguments on the stack */
  303. {
  304.     VALUE *sp;        /* pointer to stack entries */
  305.     VALUE **vpp;        /* pointer to current value address */
  306.     struct builtin *bp;    /* builtin function to be called */
  307.     long i;            /* index */
  308.     NUMBER *numargs[IN];    /* numeric arguments for function */
  309.     VALUE *valargs[IN];    /* addresses of actual arguments */
  310.     VALUE result;        /* general result of function */
  311.  
  312.     if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  313.         math_error("Bad built-in function index");
  314.     bp = &builtins[index];
  315.     if (argcount < bp->b_minargs)
  316.         math_error("Too few arguments for builtin function \"%s\"", bp->b_name);
  317.     if ((argcount > bp->b_maxargs) || (argcount > IN))
  318.         math_error("Too many arguments for builtin function \"%s\"", bp->b_name);
  319.     /*
  320.      * If an address was passed, then point at the real variable,
  321.      * otherwise point at the stack value itself (unless the function
  322.      * is very special).
  323.      */
  324.     sp = stck - argcount + 1;
  325.     vpp = valargs;
  326.     for (i = argcount; i > 0; i--) {
  327.         if ((sp->v_type != V_ADDR) || (bp->b_flags & FA))
  328.             *vpp = sp;
  329.         else
  330.             *vpp = sp->v_addr;
  331.         sp++;
  332.         vpp++;
  333.     }
  334.     /*
  335.      * Handle general values if the function accepts them.
  336.      */
  337.     if (bp->b_valfunc) {
  338.         vpp = valargs;
  339.         if ((bp->b_minargs == 1) && (bp->b_maxargs == 1))
  340.             result = (*bp->b_valfunc)(vpp[0]);
  341.         else if ((bp->b_minargs == 2) && (bp->b_maxargs == 2))
  342.             result = (*bp->b_valfunc)(vpp[0], vpp[1]);
  343.         else if ((bp->b_minargs == 3) && (bp->b_maxargs == 3))
  344.             result = (*bp->b_valfunc)(vpp[0], vpp[1], vpp[2]);
  345.         else
  346.             result = (*bp->b_valfunc)(argcount, vpp);
  347.         return result;
  348.     }
  349.     /*
  350.      * Function must be purely numeric, so handle that.
  351.      */
  352.     vpp = valargs;
  353.     for (i = 0; i < argcount; i++) {
  354.         if ((*vpp)->v_type != V_NUM)
  355.             math_error("Non-real argument for builtin function %s", bp->b_name);
  356.         numargs[i] = (*vpp)->v_num;
  357.         vpp++;
  358.     }
  359.     result.v_type = V_NUM;
  360.     if (!(bp->b_flags & FE) && (bp->b_minargs != bp->b_maxargs)) {
  361.         result.v_num = (*bp->b_numfunc)(argcount, numargs);
  362.         return result;
  363.     }
  364.     if ((bp->b_flags & FE) && (argcount < bp->b_maxargs))
  365.         numargs[argcount++] = _epsilon_;
  366.  
  367.     switch (argcount) {
  368.         case 0:
  369.             result.v_num = (*bp->b_numfunc)();
  370.             break;
  371.         case 1:
  372.             result.v_num = (*bp->b_numfunc)(numargs[0]);
  373.             break;
  374.         case 2:
  375.             result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1]);
  376.             break;
  377.         case 3:
  378.             result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1], numargs[2]);
  379.             break;
  380.         default:
  381.             math_error("Bad builtin function call");
  382.     }
  383.     return result;
  384. }
  385.  
  386.  
  387. static VALUE
  388. f_eval(vp)
  389.     VALUE *vp;
  390. {
  391.     FUNC    *oldfunc;
  392.     FUNC    *newfunc;
  393.     VALUE    result;
  394.  
  395.     if (vp->v_type != V_STR)
  396.         math_error("Evaluating non-string argument");
  397.     (void) openstring(vp->v_str);
  398.     oldfunc = curfunc;
  399.     enterfilescope();
  400.     if (evaluate(TRUE)) {
  401.         exitfilescope();
  402.         freevalue(stack--);
  403.         newfunc = curfunc;
  404.         curfunc = oldfunc;
  405.         result = newfunc->f_savedvalue;
  406.         newfunc->f_savedvalue.v_type = V_NULL;
  407.         if (newfunc != oldfunc)
  408.             free(newfunc);
  409.         return result;
  410.     }
  411.     exitfilescope();
  412.     newfunc = curfunc;
  413.     curfunc = oldfunc;
  414.     freevalue(&newfunc->f_savedvalue);
  415.     newfunc->f_savedvalue.v_type = V_NULL;
  416.     if (newfunc != oldfunc)
  417.         free(newfunc);
  418.     math_error("Evaluation error");
  419.     /*NOTREACHED*/
  420.     abort ();
  421. }
  422.  
  423.  
  424. static VALUE
  425. f_prompt(vp)
  426.     VALUE *vp;
  427. {
  428.     VALUE result;
  429.     char *cp;
  430.     char *newcp;
  431.  
  432.     if (inputisterminal()) {
  433.         printvalue(vp, PRINT_SHORT);
  434.         math_flush();
  435.     }
  436.     cp = nextline();
  437.     if (cp == NULL)
  438.         math_error("End of file while prompting");
  439.     if (*cp == '\0') {
  440.         result.v_type = V_STR;
  441.         result.v_subtype = V_STRLITERAL;
  442.         result.v_str = "";
  443.         return result;
  444.     }
  445.     newcp = (char *)malloc(strlen(cp) + 1);
  446.     if (newcp == NULL)
  447.         math_error("Cannot allocate string");
  448.     strcpy(newcp, cp);
  449.     result.v_str = newcp;
  450.     result.v_type = V_STR;
  451.     result.v_subtype = V_STRALLOC;
  452.     return result;
  453. }
  454.  
  455.  
  456. static VALUE
  457. f_str(vp)
  458.     VALUE *vp;
  459. {
  460.     VALUE result;
  461.     static char *cp;
  462.  
  463.     switch (vp->v_type) {
  464.         case V_STR:
  465.             copyvalue(vp, &result);
  466.             return result;
  467.         case V_NULL:
  468.             result.v_str = "";
  469.             result.v_type = V_STR;
  470.             result.v_subtype = V_STRLITERAL;
  471.             return result;
  472.         case V_NUM:
  473.             math_divertio();
  474.             qprintnum(vp->v_num, MODE_DEFAULT);
  475.             cp = math_getdivertedio();
  476.             break;
  477.         case V_COM:
  478.             math_divertio();
  479.             comprint(vp->v_com);
  480.             cp = math_getdivertedio();
  481.             break;
  482.         default:
  483.             math_error("Non-simple type for string conversion");
  484.     }
  485.     result.v_str = cp;
  486.     result.v_type = V_STR;
  487.     result.v_subtype = V_STRALLOC;
  488.     return result;
  489. }
  490.  
  491.  
  492. static VALUE
  493. f_poly(count, vals)
  494.     int count;
  495.     VALUE **vals;
  496. {
  497.     VALUE *x;
  498.     VALUE result, tmp;
  499.  
  500.     x = vals[--count];
  501.     copyvalue(*vals++, &result);
  502.     while (--count > 0) {
  503.         mulvalue(&result, x, &tmp);
  504.         freevalue(&result);
  505.         addvalue(*vals++, &tmp, &result);
  506.         freevalue(&tmp);
  507.     }
  508.     return result;
  509. }
  510.  
  511.  
  512. static NUMBER *
  513. f_mne(val1, val2, val3)
  514.     NUMBER *val1, *val2, *val3;
  515. {
  516.     return itoq((long) qcmpmod(val1, val2, val3));
  517. }
  518.  
  519.  
  520. static NUMBER *
  521. f_isrel(val1, val2)
  522.     NUMBER *val1, *val2;
  523. {
  524.     if (qisfrac(val1) || qisfrac(val2))
  525.         math_error("Non-integer for isrel");
  526.     return itoq((long) zrelprime(val1->num, val2->num));
  527. }
  528.  
  529.  
  530. static NUMBER *
  531. f_issquare(vp)
  532.     NUMBER *vp;
  533. {
  534.     return itoq((long) qissquare(vp));
  535. }
  536.  
  537.  
  538. static NUMBER *
  539. f_primetest(val1, val2)
  540.     NUMBER *val1, *val2;
  541. {
  542.     return itoq((long) qprimetest(val1, val2));
  543. }
  544.  
  545.  
  546. static NUMBER *
  547. f_isset(val1, val2)
  548.     NUMBER *val1, *val2;
  549. {
  550.     if (qisfrac(val2))
  551.         math_error("Non-integral bit position");
  552.     if (qiszero(val1) || (qisint(val1) && qisneg(val2)))
  553.         return qlink(&_qzero_);
  554.     if (zge31b(val2->num)) {
  555.         if (qisneg(val2))
  556.             math_error("Very large bit position");
  557.         return qlink(&_qzero_);
  558.     }
  559.     return itoq((long) qisset(val1, qtoi(val2)));
  560. }
  561.  
  562.  
  563. static NUMBER *
  564. f_digit(val1, val2)
  565.     NUMBER *val1, *val2;
  566. {
  567.     if (qisfrac(val2))
  568.         math_error("Non-integral digit position");
  569.     if (qiszero(val1) || (qisint(val1) && qisneg(val2)))
  570.         return qlink(&_qzero_);
  571.     if (zge31b(val2->num)) {
  572.         if (qisneg(val2))
  573.             math_error("Very large digit position");
  574.         return qlink(&_qzero_);
  575.     }
  576.     return itoq((long) qdigit(val1, qtoi(val2)));
  577. }
  578.  
  579.  
  580. static NUMBER *
  581. f_digits(val)
  582.     NUMBER *val;
  583. {
  584.     return itoq((long) qdigits(val));
  585. }
  586.  
  587.  
  588. static NUMBER *
  589. f_places(val)
  590.     NUMBER *val;
  591. {
  592.     return itoq((long) qplaces(val));
  593. }
  594.  
  595.  
  596. static NUMBER *
  597. f_xor(count, vals)
  598.     int count;
  599.     NUMBER **vals;
  600. {
  601.     NUMBER *val, *tmp;
  602.  
  603.     val = qlink(*vals);
  604.     while (--count > 0) {
  605.         tmp = qxor(val, *++vals);
  606.         qfree(val);
  607.         val = tmp;
  608.     }
  609.     return val;
  610. }
  611.  
  612.  
  613. static NUMBER *
  614. f_min(count, vals)
  615.     int count;
  616.     NUMBER **vals;
  617. {
  618.     NUMBER *val, *tmp;
  619.  
  620.     val = qlink(*vals);
  621.     while (--count > 0) {
  622.         tmp = qmin(val, *++vals);
  623.         qfree(val);
  624.         val = tmp;
  625.     }
  626.     return val;
  627. }
  628.  
  629.  
  630. static NUMBER *
  631. f_max(count, vals)
  632.     int count;
  633.     NUMBER **vals;
  634. {
  635.     NUMBER *val, *tmp;
  636.  
  637.     val = qlink(*vals);
  638.     while (--count > 0) {
  639.         tmp = qmax(val, *++vals);
  640.         qfree(val);
  641.         val = tmp;
  642.     }
  643.     return val;
  644. }
  645.  
  646.  
  647. static NUMBER *
  648. f_gcd(count, vals)
  649.     int count;
  650.     NUMBER **vals;
  651. {
  652.     NUMBER *val, *tmp;
  653.  
  654.     val = qabs(*vals);
  655.     while (--count > 0) {
  656.         tmp = qgcd(val, *++vals);
  657.         qfree(val);
  658.         val = tmp;
  659.     }
  660.     return val;
  661. }
  662.  
  663.  
  664. static NUMBER *
  665. f_lcm(count, vals)
  666.     int count;
  667.     NUMBER **vals;
  668. {
  669.     NUMBER *val, *tmp;
  670.  
  671.     val = qabs(*vals);
  672.     while (--count > 0) {
  673.         tmp = qlcm(val, *++vals);
  674.         qfree(val);
  675.         val = tmp;
  676.         if (qiszero(val))
  677.             break;
  678.     }
  679.     return val;
  680. }
  681.  
  682.  
  683. static VALUE
  684. f_hash(count, vals)
  685.     int count;
  686.     VALUE **vals;
  687. {
  688.     HASH hash;
  689.     long lhash;
  690.     VALUE result;
  691.  
  692.     hash = 0;
  693.     while (count-- > 0)
  694.         hash = hash * 947369 + hashvalue(*vals++);
  695.     lhash = (long) hash;
  696.     if (lhash < 0)
  697.         lhash = -lhash;
  698.     if (lhash < 0)
  699.         lhash = 0;
  700.     result.v_num = itoq(lhash);
  701.     result.v_type = V_NUM;
  702.     return result;
  703. }
  704.  
  705.  
  706. static VALUE
  707. f_avg(count, vals)
  708.     int count;
  709.     VALUE **vals;
  710. {
  711.     int i;
  712.     VALUE result;
  713.     VALUE tmp;
  714.     VALUE div;
  715.  
  716.     result.v_num = qlink(&_qzero_);
  717.     result.v_type = V_NUM;
  718.     for (i = count; i > 0; i--) {
  719.         addvalue(&result, *vals++, &tmp);
  720.         freevalue(&result);
  721.         result = tmp;
  722.     }
  723.     if (count <= 1)
  724.         return result;
  725.     div.v_num = itoq((long) count);
  726.     div.v_type = V_NUM;
  727.     divvalue(&result, &div, &tmp);
  728.     qfree(div.v_num);
  729.     return tmp;
  730. }
  731.  
  732.  
  733. static NUMBER *
  734. f_hmean(count, vals)
  735.     int count;
  736.     NUMBER **vals;
  737. {
  738.     NUMBER *val, *tmp, *tmp2, *num;
  739.  
  740.     num = itoq(count);
  741.     val = qinv(*vals);
  742.     while (--count > 0) {
  743.         tmp2 = qinv(*++vals);
  744.         tmp = qadd(val, tmp2);
  745.         qfree(tmp2);
  746.         qfree(val);
  747.         val = tmp;
  748.     }
  749.     tmp = qdiv(num, val);
  750.     qfree(num);
  751.     qfree(val);
  752.     return tmp;
  753. }
  754.  
  755.  
  756. static VALUE
  757. f_ssq(count, vals)
  758.     int count;
  759.     VALUE **vals;
  760. {
  761.     VALUE result, tmp1, tmp2;
  762.  
  763.     squarevalue(*vals++, &result);
  764.     while (--count > 0) {
  765.         squarevalue(*vals++, &tmp1);
  766.         addvalue(&tmp1, &result, &tmp2);
  767.         freevalue(&tmp1);
  768.         freevalue(&result);
  769.         result = tmp2;
  770.     }
  771.     return result;
  772. }
  773.  
  774.  
  775. static NUMBER *
  776. f_ismult(val1, val2)
  777.     NUMBER *val1, *val2;
  778. {
  779.     return itoq((long) qdivides(val1, val2));
  780. }
  781.  
  782.  
  783. static NUMBER *
  784. f_meq(val1, val2, val3)
  785.     NUMBER *val1, *val2, *val3;
  786. {
  787.     NUMBER *tmp, *res;
  788.  
  789.     tmp = qsub(val1, val2);
  790.     res = itoq((long) qdivides(tmp, val3));
  791.     qfree(tmp);
  792.     return res;
  793. }
  794.  
  795.  
  796. static VALUE
  797. f_exp(count, vals)
  798.     int count;
  799.     VALUE **vals;
  800. {
  801.     VALUE result;
  802.     NUMBER *err;
  803.  
  804.     err = _epsilon_;
  805.     if (count == 2) {
  806.         if (vals[1]->v_type != V_NUM)
  807.             math_error("Non-real epsilon value for exp");
  808.         err = vals[1]->v_num;
  809.     }
  810.     switch (vals[0]->v_type) {
  811.         case V_NUM:
  812.             result.v_num = qexp(vals[0]->v_num, err);
  813.             result.v_type = V_NUM;
  814.             break;
  815.         case V_COM:
  816.             result.v_com = cexp(vals[0]->v_com, err);
  817.             result.v_type = V_COM;
  818.             break;
  819.         default:
  820.             math_error("Bad argument type for exp");
  821.     }
  822.     return result;
  823. }
  824.  
  825.  
  826. static VALUE
  827. f_ln(count, vals)
  828.     int count;
  829.     VALUE **vals;
  830. {
  831.     VALUE result;
  832.     COMPLEX ctmp;
  833.     NUMBER *err;
  834.  
  835.     err = _epsilon_;
  836.     if (count == 2) {
  837.         if (vals[1]->v_type != V_NUM)
  838.             math_error("Non-real epsilon value for ln");
  839.         err = vals[1]->v_num;
  840.     }
  841.     switch (vals[0]->v_type) {
  842.         case V_NUM:
  843.             if (!qisneg(vals[0]->v_num) && !qiszero(vals[0]->v_num)) {
  844.                 result.v_num = qln(vals[0]->v_num, err);
  845.                 result.v_type = V_NUM;
  846.                 break;
  847.             }
  848.             ctmp.real = vals[0]->v_num;
  849.             ctmp.imag = &_qzero_;
  850.             ctmp.links = 1;
  851.             result.v_com = cln(&ctmp, err);
  852.             result.v_type = V_COM;
  853.             break;
  854.         case V_COM:
  855.             result.v_com = cln(vals[0]->v_com, err);
  856.             result.v_type = V_COM;
  857.             break;
  858.         default:
  859.             math_error("Bad argument type for ln");
  860.     }
  861.     return result;
  862. }
  863.  
  864.  
  865. static VALUE
  866. f_cos(count, vals)
  867.     int count;
  868.     VALUE **vals;
  869. {
  870.     VALUE result;
  871.     COMPLEX *c;
  872.     NUMBER *err;
  873.  
  874.     err = _epsilon_;
  875.     if (count == 2) {
  876.         if (vals[1]->v_type != V_NUM)
  877.             math_error("Non-real epsilon value for cos");
  878.         err = vals[1]->v_num;
  879.     }
  880.     switch (vals[0]->v_type) {
  881.         case V_NUM:
  882.             result.v_num = qcos(vals[0]->v_num, err);
  883.             result.v_type = V_NUM;
  884.             break;
  885.         case V_COM:
  886.             c = ccos(vals[0]->v_com, err);
  887.             result.v_com = c;
  888.             result.v_type = V_COM;
  889.             if (cisreal(c)) {
  890.                 result.v_num = qlink(c->real);
  891.                 result.v_type = V_NUM;
  892.                 comfree(c);
  893.             }
  894.             break;
  895.         default:
  896.             math_error("Bad argument type for cos");
  897.     }
  898.     return result;
  899. }
  900.  
  901.  
  902. static VALUE
  903. f_sin(count, vals)
  904.     int count;
  905.     VALUE **vals;
  906. {
  907.     VALUE result;
  908.     COMPLEX *c;
  909.     NUMBER *err;
  910.  
  911.     err = _epsilon_;
  912.     if (count == 2) {
  913.         if (vals[1]->v_type != V_NUM)
  914.             math_error("Non-real epsilon value for sin");
  915.         err = vals[1]->v_num;
  916.     }
  917.     switch (vals[0]->v_type) {
  918.         case V_NUM:
  919.             result.v_num = qsin(vals[0]->v_num, err);
  920.             result.v_type = V_NUM;
  921.             break;
  922.         case V_COM:
  923.             c = csin(vals[0]->v_com, err);
  924.             result.v_com = c;
  925.             result.v_type = V_COM;
  926.             if (cisreal(c)) {
  927.                 result.v_num = qlink(c->real);
  928.                 result.v_type = V_NUM;
  929.                 comfree(c);
  930.             }
  931.             break;
  932.         default:
  933.             math_error("Bad argument type for sin");
  934.     }
  935.     return result;
  936. }
  937.  
  938.  
  939. static VALUE
  940. f_arg(count, vals)
  941.     int count;
  942.     VALUE **vals;
  943. {
  944.     VALUE result;
  945.     COMPLEX *c;
  946.     NUMBER *err;
  947.  
  948.     err = _epsilon_;
  949.     if (count == 2) {
  950.         if (vals[1]->v_type != V_NUM)
  951.             math_error("Non-real epsilon value for arg");
  952.         err = vals[1]->v_num;
  953.     }
  954.     result.v_type = V_NUM;
  955.     switch (vals[0]->v_type) {
  956.         case V_NUM:
  957.             if (qisneg(vals[0]->v_num))
  958.                 result.v_num = qpi(err);
  959.             else
  960.                 result.v_num = qlink(&_qzero_);
  961.             break;
  962.         case V_COM:
  963.             c = vals[0]->v_com;
  964.             if (ciszero(c))
  965.                 result.v_num = qlink(&_qzero_);
  966.             else
  967.                 result.v_num = qatan2(c->imag, c->real, err);
  968.             break;
  969.         default:
  970.             math_error("Bad argument type for arg");
  971.     }
  972.     return result;
  973. }
  974.  
  975.  
  976. static NUMBER *
  977. f_legtoleg(val1, val2)
  978.     NUMBER *val1, *val2;
  979. {
  980.     return qlegtoleg(val1, val2, FALSE);
  981. }
  982.  
  983.  
  984. static NUMBER *
  985. f_trunc(count, vals)
  986.     int count;
  987.     NUMBER **vals;
  988. {
  989.     NUMBER *val;
  990.  
  991.     val = &_qzero_;
  992.     if (count == 2)
  993.         val = vals[1];
  994.     return qtrunc(*vals, val);
  995. }
  996.  
  997.  
  998. static VALUE
  999. f_bround(count, vals)
  1000.     int count;
  1001.     VALUE **vals;
  1002. {
  1003.     VALUE *vp, tmp, res;
  1004.  
  1005.     if (count > 1)
  1006.         vp = vals[1];
  1007.     else {
  1008.         tmp.v_type = V_INT;
  1009.         tmp.v_num = 0;
  1010.         vp = &tmp;
  1011.     }
  1012.     broundvalue(vals[0], vp, &res);
  1013.     return res;
  1014. }
  1015.  
  1016.  
  1017. static VALUE
  1018. f_round(count, vals)
  1019.     int count;
  1020.     VALUE **vals;
  1021. {
  1022.     VALUE *vp, tmp, res;
  1023.  
  1024.     if (count > 1)
  1025.         vp = vals[1];
  1026.     else {
  1027.         tmp.v_type = V_INT;
  1028.         tmp.v_num = 0;
  1029.         vp = &tmp;
  1030.     }
  1031.     roundvalue(vals[0], vp, &res);
  1032.     return res;
  1033. }
  1034.  
  1035.  
  1036. static NUMBER *
  1037. f_btrunc(count, vals)
  1038.     int count;
  1039.     NUMBER **vals;
  1040. {
  1041.     NUMBER *val;
  1042.  
  1043.     val = &_qzero_;
  1044.     if (count == 2)
  1045.         val = vals[1];
  1046.     return qbtrunc(*vals, val);
  1047. }
  1048.  
  1049.  
  1050. static NUMBER *
  1051. f_near(count, vals)
  1052.     int count;
  1053.     NUMBER **vals;
  1054. {
  1055.     NUMBER *val;
  1056.  
  1057.     val = _epsilon_;
  1058.     if (count == 3)
  1059.         val = vals[2];
  1060.     return itoq((long) qnear(vals[0], vals[1], val));
  1061. }
  1062.  
  1063.  
  1064. static NUMBER *
  1065. f_cfsim(val)
  1066.     NUMBER *val;
  1067. {
  1068.     return qcfappr(val, NULL);
  1069. }
  1070.  
  1071.  
  1072. static NUMBER *
  1073. f_ceil(val)
  1074.     NUMBER *val;
  1075. {
  1076.     NUMBER *val2;
  1077.  
  1078.     if (qisint(val))
  1079.         return qlink(val);
  1080.     val2 = qint(val);
  1081.     if (qisneg(val))
  1082.         return val2;
  1083.     val = qinc(val2);
  1084.     qfree(val2);
  1085.     return val;
  1086. }
  1087.  
  1088.  
  1089. static NUMBER *
  1090. f_floor(val)
  1091.     NUMBER *val;
  1092. {
  1093.     NUMBER *val2;
  1094.  
  1095.     if (qisint(val))
  1096.         return qlink(val);
  1097.     val2 = qint(val);
  1098.     if (!qisneg(val))
  1099.         return val2;
  1100.     val = qdec(val2);
  1101.     qfree(val2);
  1102.     return val;
  1103. }
  1104.  
  1105.  
  1106. static NUMBER *
  1107. f_highbit(val)
  1108.     NUMBER *val;
  1109. {
  1110.     if (qiszero(val))
  1111.         math_error("Highbit of zero");
  1112.     if (qisfrac(val))
  1113.         math_error("Highbit of non-integer");
  1114.     return itoq(zhighbit(val->num));
  1115. }
  1116.  
  1117.  
  1118. static NUMBER *
  1119. f_lowbit(val)
  1120.     NUMBER *val;
  1121. {
  1122.     if (qiszero(val))
  1123.         math_error("Lowbit of zero");
  1124.     if (qisfrac(val))
  1125.         math_error("Lowbit of non-integer");
  1126.     return itoq(zlowbit(val->num));
  1127. }
  1128.  
  1129.  
  1130. static VALUE
  1131. f_sqrt(count, vals)
  1132.     int count;
  1133.     VALUE **vals;
  1134. {
  1135.     VALUE *vp, err, result;
  1136.  
  1137.     if (count > 1)
  1138.         vp = vals[1];
  1139.     else {
  1140.         err.v_num = _epsilon_;
  1141.         err.v_type = V_NUM;
  1142.         vp = &err;
  1143.     }
  1144.     sqrtvalue(vals[0], vp, &result);
  1145.     return result;
  1146. }
  1147.  
  1148.  
  1149. static VALUE
  1150. f_root(count, vals)
  1151.     int count;
  1152.     VALUE **vals;
  1153. {
  1154.     VALUE *vp, err, result;
  1155.  
  1156.     if (count > 2)
  1157.         vp = vals[3];
  1158.     else {
  1159.         err.v_num = _epsilon_;
  1160.         err.v_type = V_NUM;
  1161.         vp = &err;
  1162.     }
  1163.     rootvalue(vals[0], vals[1], vp, &result);
  1164.     return result;
  1165. }
  1166.  
  1167.  
  1168. static VALUE
  1169. f_power(count, vals)
  1170.     int count;
  1171.     VALUE **vals;
  1172. {
  1173.     VALUE *vp, err, result;
  1174.  
  1175.     if (count > 2)
  1176.         vp = vals[2];
  1177.     else {
  1178.         err.v_num = _epsilon_;
  1179.         err.v_type = V_NUM;
  1180.         vp = &err;
  1181.     }
  1182.     powervalue(vals[0], vals[1], vp, &result);
  1183.     return result;
  1184. }
  1185.  
  1186.  
  1187. static VALUE
  1188. f_polar(count, vals)
  1189.     int count;
  1190.     VALUE **vals;
  1191. {
  1192.     VALUE *vp, err, result;
  1193.     COMPLEX *c;
  1194.  
  1195.     if (count > 2)
  1196.         vp = vals[2];
  1197.     else {
  1198.         err.v_num = _epsilon_;
  1199.         err.v_type = V_NUM;
  1200.         vp = &err;
  1201.     }
  1202.     if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM))
  1203.         math_error("Non-real argument for polar");
  1204.     if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num))
  1205.         math_error("Bad epsilon value for polar");
  1206.     c = cpolar(vals[0]->v_num, vals[1]->v_num, vp->v_num);
  1207.     result.v_com = c;
  1208.     result.v_type = V_COM;
  1209.     if (cisreal(c)) {
  1210.         result.v_num = qlink(c->real);
  1211.         result.v_type = V_NUM;
  1212.         comfree(c);
  1213.     }
  1214.     return result;
  1215. }
  1216.  
  1217.  
  1218. static NUMBER *
  1219. f_ilog(val1, val2)
  1220.     NUMBER *val1, *val2;
  1221. {
  1222.     return itoq(qilog(val1, val2));
  1223. }
  1224.  
  1225.  
  1226. static NUMBER *
  1227. f_ilog2(val)
  1228.     NUMBER *val;
  1229. {
  1230.     return itoq(qilog2(val));
  1231. }
  1232.  
  1233.  
  1234. static NUMBER *
  1235. f_ilog10(val)
  1236.     NUMBER *val;
  1237. {
  1238.     return itoq(qilog10(val));
  1239. }
  1240.  
  1241.  
  1242. static NUMBER *
  1243. f_faccnt(val1, val2)
  1244.     NUMBER *val1, *val2;
  1245. {
  1246.     return itoq(qdivcount(val1, val2));
  1247. }
  1248.  
  1249.  
  1250. static VALUE
  1251. f_matfill(count, vals)
  1252.     int count;
  1253.     VALUE **vals;
  1254. {
  1255.     VALUE *v1, *v2, *v3;
  1256.     VALUE result;
  1257.  
  1258.     v1 = vals[0];
  1259.     v2 = vals[1];
  1260.     v3 = (count == 3) ? vals[2] : NULL;
  1261.     if (v1->v_type != V_ADDR)
  1262.         math_error("Non-variable argument for matfill");
  1263.     v1 = v1->v_addr;
  1264.     if (v1->v_type != V_MAT)
  1265.         math_error("Non-matrix for matfill");
  1266.     if (v2->v_type == V_ADDR)
  1267.         v2 = v2->v_addr;
  1268.     if (v3 && (v3->v_type == V_ADDR))
  1269.         v3 = v3->v_addr;
  1270.     matfill(v1->v_mat, v2, v3);
  1271.     result.v_type = V_NULL;
  1272.     return result;
  1273. }
  1274.  
  1275.  
  1276. static VALUE
  1277. f_mattrans(vp)
  1278.     VALUE *vp;
  1279. {
  1280.     VALUE result;
  1281.  
  1282.     if (vp->v_type != V_MAT)
  1283.         math_error("Non-matrix argument for mattrans");
  1284.     result.v_type = V_MAT;
  1285.     result.v_mat = mattrans(vp->v_mat);
  1286.     return result;
  1287. }
  1288.  
  1289.  
  1290. static VALUE
  1291. f_det(vp)
  1292.     VALUE *vp;
  1293. {
  1294.     if (vp->v_type != V_MAT)
  1295.         math_error("Non-matrix argument for det");
  1296.     return matdet(vp->v_mat);
  1297. }
  1298.  
  1299.  
  1300. static VALUE
  1301. f_matdim(vp)
  1302.     VALUE *vp;
  1303. {
  1304.     VALUE result;
  1305.  
  1306.     if (vp->v_type != V_MAT)
  1307.         math_error("Non-matrix argument for matdim");
  1308.     result.v_type = V_NUM;
  1309.     result.v_num = itoq((long) vp->v_mat->m_dim);
  1310.     return result;
  1311. }
  1312.  
  1313.  
  1314. static VALUE
  1315. f_matmin(v1, v2)
  1316.     VALUE *v1, *v2;
  1317. {
  1318.     VALUE result;
  1319.     NUMBER *q;
  1320.     long i;
  1321.  
  1322.     if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM))
  1323.         math_error("Bad argument type for matmin");
  1324.     q = v2->v_num;
  1325.     i = qtoi(q);
  1326.     if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim))
  1327.         math_error("Bad dimension value for matmin");
  1328.     result.v_type = V_NUM;
  1329.     result.v_num = itoq(v1->v_mat->m_min[i - 1]);
  1330.     return result;
  1331. }
  1332.  
  1333.  
  1334. static VALUE
  1335. f_matmax(v1, v2)
  1336.     VALUE *v1, *v2;
  1337. {
  1338.     VALUE result;
  1339.     NUMBER *q;
  1340.     long i;
  1341.  
  1342.     if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM))
  1343.         math_error("Bad argument type for matmax");
  1344.     q = v2->v_num;
  1345.     i = qtoi(q);
  1346.     if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim))
  1347.         math_error("Bad dimension value for matmax");
  1348.     result.v_type = V_NUM;
  1349.     result.v_num = itoq(v1->v_mat->m_max[i - 1]);
  1350.     return result;
  1351. }
  1352.  
  1353.  
  1354. static VALUE
  1355. f_cp(v1, v2)
  1356.     VALUE *v1, *v2;
  1357. {
  1358.     VALUE result;
  1359.  
  1360.     if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
  1361.         math_error("Non-matrix argument for cross product");
  1362.     result.v_type = V_MAT;
  1363.     result.v_mat = matcross(v1->v_mat, v2->v_mat);
  1364.     return result;
  1365. }
  1366.  
  1367.  
  1368. static VALUE
  1369. f_dp(v1, v2)
  1370.     VALUE *v1, *v2;
  1371. {
  1372.     if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
  1373.         math_error("Non-matrix argument for dot product");
  1374.     return matdot(v1->v_mat, v2->v_mat);
  1375. }
  1376.  
  1377.  
  1378. static VALUE
  1379. f_strlen(vp)
  1380.     VALUE *vp;
  1381. {
  1382.     VALUE result;
  1383.  
  1384.     if (vp->v_type != V_STR)
  1385.         math_error("Non-string argument for strlen");
  1386.     result.v_type = V_NUM;
  1387.     result.v_num = itoq((long) strlen(vp->v_str));
  1388.     return result;
  1389. }
  1390.  
  1391.  
  1392. static VALUE
  1393. f_strcat(count, vals)
  1394.     int count;
  1395.     VALUE **vals;
  1396. {
  1397.     register VALUE **vp;
  1398.     register char *cp;
  1399.     int i;
  1400.     long len;
  1401.     long lengths[IN];
  1402.     VALUE result;
  1403.  
  1404.     len = 1;
  1405.     vp = vals;
  1406.     for (i = 0; i < count; i++) {
  1407.         if ((*vp)->v_type != V_STR)
  1408.             math_error("Non-string argument for strcat");
  1409.         lengths[i] = strlen((*vp)->v_str);
  1410.         len += lengths[i];
  1411.         vp++;
  1412.     }
  1413.     cp = (char *)malloc(len);
  1414.     if (cp == NULL)
  1415.         math_error("No memory for strcat");
  1416.     result.v_str = cp;
  1417.     result.v_type = V_STR;
  1418.     result.v_subtype = V_STRALLOC;
  1419.     i = 0;
  1420.     for (vp = vals; count-- > 0; vp++) {
  1421.         strcpy(cp, (*vp)->v_str);
  1422.         cp += lengths[i++];
  1423.     }
  1424.     return result;
  1425. }
  1426.  
  1427.  
  1428. static VALUE
  1429. f_substr(v1, v2, v3)
  1430.     VALUE *v1, *v2, *v3;
  1431. {
  1432.     NUMBER *q1, *q2;
  1433.     long i1, i2, len;
  1434.     char *cp;
  1435.     VALUE result;
  1436.  
  1437.     if (v1->v_type != V_STR)
  1438.         math_error("Non-string argument for substr");
  1439.     if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
  1440.         math_error("Non-numeric positions for substr");
  1441.     q1 = v2->v_num;
  1442.     q2 = v3->v_num;
  1443.     if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2))
  1444.         math_error("Illegal positions for substr");
  1445.     i1 = qtoi(q1);
  1446.     i2 = qtoi(q2);
  1447.     cp = v1->v_str;
  1448.     len = strlen(cp);
  1449.     result.v_type = V_STR;
  1450.     if (i1 > 0)
  1451.         i1--;
  1452.     if (i1 >= len) {    /* indexing off of end */
  1453.         result.v_subtype = V_STRLITERAL;
  1454.         result.v_str = "";
  1455.         return result;
  1456.     }
  1457.     cp += i1;
  1458.     len -= i1;
  1459.     if ((i2 >= len) && (v1->v_subtype == V_STRLITERAL)) {
  1460.         result.v_subtype = V_STRLITERAL;
  1461.         result.v_str = cp;
  1462.         return result;
  1463.     }
  1464.     if (len > i2)
  1465.         len = i2;
  1466.     if (len == 1) {
  1467.         result.v_subtype = V_STRLITERAL;
  1468.         result.v_str = charstr(*cp);
  1469.         return result;
  1470.     }
  1471.     result.v_subtype = V_STRALLOC;
  1472.     result.v_str = (char *)malloc(len + 1);
  1473.     if (result.v_str == NULL)
  1474.         math_error("No memory for substr");
  1475.     strncpy(result.v_str, cp, len);
  1476.     result.v_str[len] = '\0';
  1477.     return result;
  1478. }
  1479.  
  1480.  
  1481. static VALUE
  1482. f_char(vp)
  1483.     VALUE *vp;
  1484. {
  1485.     long num;
  1486.     NUMBER *q;
  1487.     VALUE result;
  1488.  
  1489.     if (vp->v_type != V_NUM)
  1490.         math_error("Non-numeric argument for char");
  1491.     q = vp->v_num;
  1492.     num = qtoi(q);
  1493.     if (qisneg(q) || qisfrac(q) || !zistiny(q->num) || (num > 255))
  1494.         math_error("Illegal number for char");
  1495.     result.v_type = V_STR;
  1496.     result.v_subtype = V_STRLITERAL;
  1497.     result.v_str = charstr((int) num);
  1498.     return result;
  1499. }
  1500.  
  1501.  
  1502. static VALUE
  1503. f_ord(vp)
  1504.     VALUE *vp;
  1505. {
  1506.     char *str;
  1507.     VALUE result;
  1508.  
  1509.     if (vp->v_type != V_STR)
  1510.         math_error("Non-string argument for ord");
  1511.     str = vp->v_str;
  1512.     if (str[0] && str[1])
  1513.         math_error("Multi-character string given for ord");
  1514.     result.v_type = V_NUM;
  1515.     result.v_num = itoq((long) (*str & 0xff));
  1516.     return result;
  1517. }
  1518.  
  1519.  
  1520. static VALUE
  1521. f_size(vp)
  1522.     VALUE *vp;
  1523. {
  1524.     long count;
  1525.     VALUE result;
  1526.  
  1527.     switch (vp->v_type) {
  1528.         case V_NULL:    count = 0; break;
  1529.         case V_MAT:    count = vp->v_mat->m_size; break;
  1530.         case V_LIST:    count = vp->v_list->l_count; break;
  1531.         case V_ASSOC:    count = vp->v_assoc->a_count; break;
  1532.         case V_OBJ:    count = vp->v_obj->o_actions->count; break;
  1533.         default:    count = 1; break;
  1534.     }
  1535.     result.v_type = V_NUM;
  1536.     result.v_num = itoq(count);
  1537.     return result;
  1538. }
  1539.  
  1540.  
  1541. static VALUE
  1542. f_search(count, vals)
  1543.     int count;
  1544.     VALUE **vals;
  1545. {
  1546.     VALUE *v1, *v2;
  1547.     NUMBER *q;
  1548.     long start;
  1549.     long index = -1;
  1550.     VALUE result;
  1551.  
  1552.     v1 = *vals++;
  1553.     v2 = *vals++;
  1554.     start = 0;
  1555.     if (count == 3) {
  1556.         if ((*vals)->v_type != V_NUM)
  1557.             math_error("Non-numeric start index for search");
  1558.         q = (*vals)->v_num;
  1559.         if (qisfrac(q) || qisneg(q))
  1560.             math_error("Bad start index for search");
  1561.         start = qtoi(q);
  1562.     }
  1563.     switch (v1->v_type) {
  1564.         case V_MAT:
  1565.             index = matsearch(v1->v_mat, v2, start);
  1566.             break;
  1567.         case V_LIST:
  1568.             index = listsearch(v1->v_list, v2, start);
  1569.             break;
  1570.         case V_ASSOC:
  1571.             index = assocsearch(v1->v_assoc, v2, start);
  1572.             break;
  1573.         default:
  1574.             math_error("Bad argument type for search");
  1575.     }
  1576.     result.v_type = V_NULL;
  1577.     if (index >= 0) {
  1578.         result.v_type = V_NUM;
  1579.         result.v_num = itoq(index);
  1580.     }
  1581.     return result;
  1582. }
  1583.  
  1584.  
  1585. static VALUE
  1586. f_rsearch(count, vals)
  1587.     int count;
  1588.     VALUE **vals;
  1589. {
  1590.     VALUE *v1, *v2;
  1591.     NUMBER *q;
  1592.     long start;
  1593.     long index = -1;
  1594.     VALUE result;
  1595.  
  1596.     v1 = *vals++;
  1597.     v2 = *vals++;
  1598.     start = MAXFULL;
  1599.     if (count == 3) {
  1600.         if ((*vals)->v_type != V_NUM)
  1601.             math_error("Non-numeric start index for rsearch");
  1602.         q = (*vals)->v_num;
  1603.         if (qisfrac(q) || qisneg(q))
  1604.             math_error("Bad start index for rsearch");
  1605.         start = qtoi(q);
  1606.     }
  1607.     switch (v1->v_type) {
  1608.         case V_MAT:
  1609.             index = matrsearch(v1->v_mat, v2, start);
  1610.             break;
  1611.         case V_LIST:
  1612.             index = listrsearch(v1->v_list, v2, start);
  1613.             break;
  1614.         case V_ASSOC:
  1615.             index = assocrsearch(v1->v_assoc, v2, start);
  1616.             break;
  1617.         default:
  1618.             math_error("Bad argument type for rsearch");
  1619.     }
  1620.     result.v_type = V_NULL;
  1621.     if (index >= 0) {
  1622.         result.v_type = V_NUM;
  1623.         result.v_num = itoq(index);
  1624.     }
  1625.     return result;
  1626. }
  1627.  
  1628.  
  1629. static VALUE
  1630. f_list(count, vals)
  1631.     int count;
  1632.     VALUE **vals;
  1633. {
  1634.     VALUE result;
  1635.  
  1636.     result.v_type = V_LIST;
  1637.     result.v_list = listalloc();
  1638.     while (count-- > 0)
  1639.         insertlistlast(result.v_list, *vals++);
  1640.     return result;
  1641. }
  1642.  
  1643.  
  1644. /*ARGSUSED*/
  1645. static VALUE
  1646. f_assoc(count, vals)
  1647.     int count;
  1648.     VALUE **vals;
  1649. {
  1650.     VALUE result;
  1651.  
  1652.     result.v_type = V_ASSOC;
  1653.     result.v_assoc = assocalloc(0L);
  1654.     return result;
  1655. }
  1656.  
  1657.  
  1658. static VALUE
  1659. f_listinsert(v1, v2, v3)
  1660.     VALUE *v1, *v2, *v3;
  1661. {
  1662.     VALUE result;
  1663.  
  1664.     if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1665.         math_error("Inserting into non-list variable");
  1666.     if (v2->v_type == V_ADDR)
  1667.         v2 = v2->v_addr;
  1668.     if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
  1669.         math_error("Non-integral index for list insert");
  1670.     if (v3->v_type == V_ADDR)
  1671.         v3 = v3->v_addr;
  1672.     insertlistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), v3);
  1673.     result.v_type = V_NULL;
  1674.     return result;
  1675. }
  1676.  
  1677.  
  1678. static VALUE
  1679. f_listpush(v1, v2)
  1680.     VALUE *v1, *v2;
  1681. {
  1682.     VALUE result;
  1683.  
  1684.     if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1685.         math_error("Pushing onto non-list variable");
  1686.     if (v2->v_type == V_ADDR)
  1687.         v2 = v2->v_addr;
  1688.     insertlistfirst(v1->v_addr->v_list, v2);
  1689.     result.v_type = V_NULL;
  1690.     return result;
  1691. }
  1692.  
  1693.  
  1694. static VALUE
  1695. f_listappend(v1, v2)
  1696.     VALUE *v1, *v2;
  1697. {
  1698.     VALUE result;
  1699.  
  1700.     if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1701.         math_error("Appending to non-list variable");
  1702.     if (v2->v_type == V_ADDR)
  1703.         v2 = v2->v_addr;
  1704.     insertlistlast(v1->v_addr->v_list, v2);
  1705.     result.v_type = V_NULL;
  1706.     return result;
  1707. }
  1708.  
  1709.  
  1710. static VALUE
  1711. f_listdelete(v1, v2)
  1712.     VALUE *v1, *v2;
  1713. {
  1714.     VALUE result;
  1715.  
  1716.     if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1717.         math_error("Deleting from non-list variable");
  1718.     if (v2->v_type == V_ADDR)
  1719.         v2 = v2->v_addr;
  1720.     if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
  1721.         math_error("Non-integral index for list delete");
  1722.     removelistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), &result);
  1723.     return result;
  1724. }
  1725.  
  1726.  
  1727. static VALUE
  1728. f_listpop(vp)
  1729.     VALUE *vp;
  1730. {
  1731.     VALUE result;
  1732.  
  1733.     if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
  1734.         math_error("Popping from non-list variable");
  1735.     removelistfirst(vp->v_addr->v_list, &result);
  1736.     return result;
  1737. }
  1738.  
  1739.  
  1740. static VALUE
  1741. f_listremove(vp)
  1742.     VALUE *vp;
  1743. {
  1744.     VALUE result;
  1745.  
  1746.     if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
  1747.         math_error("Removing from non-list variable");
  1748.     removelistlast(vp->v_addr->v_list, &result);
  1749.     return result;
  1750. }
  1751.  
  1752.  
  1753. /*
  1754.  * Return the current runtime of calc in seconds.
  1755.  * This is the user mode time only.
  1756.  */
  1757. static NUMBER *
  1758. f_runtime()
  1759. {
  1760.     return itoq(time(NULL));
  1761. }
  1762.  
  1763. static VALUE
  1764. f_fopen(v1, v2)
  1765.     VALUE *v1, *v2;
  1766. {
  1767.     VALUE result;
  1768.     FILEID id;
  1769.  
  1770.     if (v1->v_type != V_STR)
  1771.         math_error("Non-string filename for fopen");
  1772.     if (v2->v_type != V_STR)
  1773.         math_error("Non-string mode for fopen");
  1774.     id = openid(v1->v_str, v2->v_str);
  1775.     if (id == FILEID_NONE) {
  1776.         result.v_type = V_NUM;
  1777.         result.v_num = itoq((long) errno);
  1778.     } else {
  1779.         result.v_type = V_FILE;
  1780.         result.v_file = id;
  1781.     }
  1782.     return result;
  1783. }
  1784.  
  1785.  
  1786. static VALUE
  1787. f_fclose(vp)
  1788.     VALUE *vp;
  1789. {
  1790.     VALUE result;
  1791.  
  1792.     if (vp->v_type != V_FILE)
  1793.         math_error("Non-file for fclose");
  1794.     if (closeid(vp->v_file)) {
  1795.         result.v_type = V_NUM;
  1796.         result.v_num = itoq((long) errno);
  1797.     } else
  1798.         result.v_type = V_NULL;
  1799.     return result;
  1800. }
  1801.  
  1802.  
  1803. static VALUE
  1804. f_ferror(vp)
  1805.     VALUE *vp;
  1806. {
  1807.     VALUE result;
  1808.  
  1809.     if (vp->v_type != V_FILE)
  1810.         math_error("Non-file for ferror");
  1811.     result.v_type = V_NUM;
  1812.     result.v_num = itoq((long) errorid(vp->v_file));
  1813.     return result;
  1814. }
  1815.  
  1816.  
  1817. static VALUE
  1818. f_feof(vp)
  1819.     VALUE *vp;
  1820. {
  1821.     VALUE result;
  1822.  
  1823.     if (vp->v_type != V_FILE)
  1824.         math_error("Non-file for feof");
  1825.     result.v_type = V_NUM;
  1826.     result.v_num = itoq((long) eofid(vp->v_file));
  1827.     return result;
  1828. }
  1829.  
  1830.  
  1831. static VALUE
  1832. f_fflush(vp)
  1833.     VALUE *vp;
  1834. {
  1835.     VALUE result;
  1836.  
  1837.     if (vp->v_type != V_FILE)
  1838.         math_error("Non-file for fflush");
  1839.     flushid(vp->v_file);
  1840.     result.v_type = V_NULL;
  1841.     return result;
  1842. }
  1843.  
  1844.  
  1845. static VALUE
  1846. f_fprintf(count, vals)
  1847.     int count;
  1848.     VALUE **vals;
  1849. {
  1850.     VALUE result;
  1851.  
  1852.     if (vals[0]->v_type != V_FILE)
  1853.         math_error("Non-file for fprintf");
  1854.     if (vals[1]->v_type != V_STR)
  1855.         math_error("Non-string format for fprintf");
  1856.     idprintf(vals[0]->v_file, vals[1]->v_str, count - 2, vals + 2);
  1857.     result.v_type = V_NULL;
  1858.     return result;
  1859. }
  1860.  
  1861.  
  1862. static VALUE
  1863. f_printf(count, vals)
  1864.     int count;
  1865.     VALUE **vals;
  1866. {
  1867.     VALUE result;
  1868.  
  1869.     if (vals[0]->v_type != V_STR)
  1870.         math_error("Non-string format for printf");
  1871.     idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1);
  1872.     result.v_type = V_NULL;
  1873.     return result;
  1874. }
  1875.  
  1876.  
  1877. static VALUE
  1878. f_strprintf(count, vals)
  1879.     int count;
  1880.     VALUE **vals;
  1881. {
  1882.     VALUE result;
  1883.  
  1884.     if (vals[0]->v_type != V_STR)
  1885.         math_error("Non-string format for strprintf");
  1886.     math_divertio();
  1887.     idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1);
  1888.     result.v_str = math_getdivertedio();
  1889.     result.v_type = V_STR;
  1890.     result.v_subtype = V_STRALLOC;
  1891.     return result;
  1892. }
  1893.  
  1894.  
  1895. static VALUE
  1896. f_fgetc(vp)
  1897.     VALUE *vp;
  1898. {
  1899.     VALUE result;
  1900.     int ch;
  1901.  
  1902.     if (vp->v_type != V_FILE)
  1903.         math_error("Non-file for fgetc");
  1904.     ch = getcharid(vp->v_file);
  1905.     result.v_type = V_NULL;
  1906.     if (ch != EOF) {
  1907.         result.v_type = V_STR;
  1908.         result.v_subtype = V_STRLITERAL;
  1909.         result.v_str = charstr(ch);
  1910.     }
  1911.     return result;
  1912. }
  1913.  
  1914.  
  1915. static VALUE
  1916. f_fgetline(vp)
  1917.     VALUE *vp;
  1918. {
  1919.     VALUE result;
  1920.     char *str;
  1921.  
  1922.     if (vp->v_type != V_FILE)
  1923.         math_error("Non-file for fgetline");
  1924.     readid(vp->v_file, &str);
  1925.     result.v_type = V_NULL;
  1926.     if (str) {
  1927.         result.v_type = V_STR;
  1928.         result.v_subtype = V_STRALLOC;
  1929.         result.v_str = str;
  1930.     }
  1931.     return result;
  1932. }
  1933.  
  1934.  
  1935. static VALUE
  1936. f_files(count, vals)
  1937.     int count;
  1938.     VALUE **vals;
  1939. {
  1940.     VALUE result;
  1941.  
  1942.     if (count == 0) {
  1943.         result.v_type = V_NUM;
  1944.         result.v_num = itoq((long) MAXFILES);
  1945.         return result;
  1946.     }
  1947.     if ((vals[0]->v_type != V_NUM) || qisfrac(vals[0]->v_num))
  1948.         math_error("Non-integer for files");
  1949.     result.v_type = V_NULL;
  1950.     result.v_file = indexid(qtoi(vals[0]->v_num));
  1951.     if (result.v_file != FILEID_NONE)
  1952.         result.v_type = V_FILE;
  1953.     return result;
  1954. }
  1955.  
  1956.  
  1957. /*
  1958.  * return a numerical 'value' of the mode/base
  1959.  */
  1960. static NUMBER *
  1961. base_value(mode)
  1962.     long mode;    /* a MODE_XYZ value */
  1963. {
  1964.     NUMBER *result;
  1965.  
  1966.     /* return the old base */
  1967.     switch (mode) {
  1968.     case MODE_DEFAULT:
  1969.         if (_outmode_ == MODE_DEFAULT) {
  1970.             result = itoq(10); /* firewall */
  1971.         } else {
  1972.             result = base_value(_outmode_);
  1973.         }
  1974.         break;
  1975.     case MODE_FRAC:
  1976.         result = qalloc();
  1977.         itoz(3, &result->den);
  1978.         break;
  1979.     case MODE_INT:
  1980.         result = itoq(-10);
  1981.         break;
  1982.     case MODE_REAL:
  1983.         result = itoq(10);
  1984.         break;
  1985.     case MODE_EXP:
  1986.         result = qalloc();
  1987.         ztenpow(20, &result->num);
  1988.         break;
  1989.     case MODE_HEX:
  1990.         result = itoq(16);
  1991.         break;
  1992.     case MODE_OCTAL:
  1993.         result = itoq(8);
  1994.         break;
  1995.     case MODE_BINARY:
  1996.         result = itoq(2);
  1997.         break;
  1998.     default:
  1999.         result = itoq(0);
  2000.         break;
  2001.     }
  2002.     return result;
  2003. }
  2004.  
  2005.  
  2006. /*
  2007.  * set the default output base/mode
  2008.  */
  2009. static NUMBER *
  2010. f_base(count, vals)
  2011.     int count;
  2012.     NUMBER **vals;
  2013. {
  2014.     long base;    /* output base/mode */
  2015.     long oldbase=0;    /* output base/mode */
  2016.  
  2017.     /* deal with just a query */
  2018.     if (count != 1) {
  2019.         return base_value(_outmode_);
  2020.     }
  2021.  
  2022.     /* deal with the specal modes first */
  2023.     if (qisfrac(vals[0])) {
  2024.         return base_value(math_setmode(MODE_FRAC));
  2025.     }
  2026.     if (vals[0]->num.len > 64/BASEB) {
  2027.         return base_value(math_setmode(MODE_EXP));
  2028.     }
  2029.  
  2030.     /* set the base, if possible */
  2031.     base = qtoi(vals[0]);
  2032.     switch (base) {
  2033.     case -10:
  2034.         oldbase = math_setmode(MODE_INT);
  2035.         break;
  2036.     case 2:
  2037.         oldbase = math_setmode(MODE_BINARY);
  2038.         break;
  2039.     case 8:
  2040.         oldbase = math_setmode(MODE_OCTAL);
  2041.         break;
  2042.     case 10:
  2043.         oldbase = math_setmode(MODE_REAL);
  2044.         break;
  2045.     case 16:
  2046.         oldbase = math_setmode(MODE_HEX);
  2047.         break;
  2048.     default:
  2049.         math_error("Unsupported base");
  2050.         break;
  2051.     }
  2052.  
  2053.     /* return the old base */
  2054.     return base_value(oldbase);
  2055. }
  2056.  
  2057.  
  2058. /*
  2059.  * Show the list of primitive built-in functions
  2060.  */
  2061. void
  2062. showbuiltins()
  2063. {
  2064.     register struct builtin *bp;    /* current function */
  2065.  
  2066.     printf("\nName\tArgs\tDescription\n\n");
  2067.     for (bp = builtins; bp->b_name; bp++) {
  2068.         printf("%-9s ", bp->b_name);
  2069.         if (bp->b_maxargs == IN)
  2070.             printf("%d+    ", bp->b_minargs);
  2071.         else if (bp->b_minargs == bp->b_maxargs)
  2072.             printf("%-6d", bp->b_minargs);
  2073.         else
  2074.             printf("%d-%-4d", bp->b_minargs, bp->b_maxargs);
  2075.         printf(" %s\n", bp->b_desc);
  2076.     }
  2077.     printf("\n");
  2078. }
  2079.  
  2080.  
  2081. /*
  2082.  * Return the index of a built-in function given its name.
  2083.  * Returns minus one if the name is not known.
  2084.  */
  2085. int
  2086. getbuiltinfunc(name)
  2087.     char *name;
  2088. {
  2089.     register struct builtin *bp;
  2090.  
  2091.     for (bp = builtins; bp->b_name; bp++) {
  2092.         if ((*name == *bp->b_name) && (strcmp(name, bp->b_name) == 0))
  2093.         return (bp - builtins);
  2094.     }
  2095.     return -1;
  2096. }
  2097.  
  2098.  
  2099. /*
  2100.  * Given the index of a built-in function, return its name.
  2101.  */
  2102. char *
  2103. builtinname(index)
  2104.     long index;
  2105. {
  2106.     if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  2107.         return "";
  2108.     return builtins[index].b_name;
  2109. }
  2110.  
  2111.  
  2112. /*
  2113.  * Given the index of a built-in function, and the number of arguments seen,
  2114.  * determine if the number of arguments are legal.  This routine is called
  2115.  * during parsing time.
  2116.  */
  2117. void
  2118. builtincheck(index, count)
  2119.     int count;
  2120.     long index;
  2121. {
  2122.     register struct builtin *bp;
  2123.  
  2124.     if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  2125.         math_error("Unknown built in index");
  2126.     bp = &builtins[index];
  2127.     if (count < bp->b_minargs)
  2128.         scanerror(T_NULL, "Too few arguments for builtin function \"%s\"",
  2129.     bp->b_name);
  2130.     if (count > bp->b_maxargs)
  2131.         scanerror(T_NULL, "Too many arguments for builtin function \"%s\"",
  2132.             bp->b_name);
  2133. }
  2134.  
  2135.  
  2136. /*
  2137.  * Return the opcode for a built-in function that can be used to avoid
  2138.  * the function call at all.
  2139.  */
  2140. int
  2141. builtinopcode(index)
  2142.     long index;
  2143. {
  2144.     if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  2145.         return OP_NOP;
  2146.     return builtins[index].b_opcode;
  2147. }
  2148.  
  2149. /* END CODE */
  2150.